C/C++ Users Group Library 1996 July/C-C++ Users Group Library July 1996.iso/vol_400/427_01/testware/multicfg.pas

Pascal/Delphi Source File | 1994-03-23 | 8.1 KB | 323 lines

program MULTIjoy_ConFiG_file_maker;


(* creates multijoy config files by asking the user to push a specified
   joystick into a specified direction and scanning the printer port for
   changes
*)


uses  dos,
      crt;


const direction  : array [1 .. 6] of string
                 = ('left', 'right', 'up', 'down', 'fire', 'extra');

      action     : array [1 .. 6] of char
                 = ('l', 'r', 'u', 'd', 'f', '*');


type  Tpin       = (none, pe, busy);

      Taddress   = record
                     address : byte;
                     pin     : Tpin;
                   end;


var   assignment : array [1 .. 6, 1 .. 6] of Taddress;
      pout,
      p_in       : word;
      multipath  : string;


procedure error_msg (msg_nr, code : integer);
(* displays error message and halts the program if necessary *)
begin
  writeln ('MULTICFG error message:');
  case msg_nr of
     1 : begin
           writeln ('DOS environment does not contain MULTIPATH (path of config file)');
           halt;
         end;
     2 : begin
           writeln ('Invalid DOS environment variable MULTIPORT (''', chr (code), ''')');
           halt;
         end;
     3 : begin
           writeln ('DOS environment variable MULTIPORT must have only one digit!');
           halt;
         end;
     4 : begin
           writeln ('Config file write error #', code);
           halt;
         end;
     0 : writeln ('Test #', code)
    else begin
      writeln ('critical error - no appropriate error message found (error #', code, ')');
      halt;
    end;
  end;
end;


procedure init;
(* initializes screen
   reads path to write config file to from DOS environment
   reads printer port number from DOS environment (if set)
   zeros assignment table                                  *)


  function get_port_nr (multiport : string) : byte;
  (* find printer port number in a string *)
  var port : char;
  begin
    port := multiport [1];
    if not (port in ['1' .. '3']) then error_msg (2, ord (port));
    get_port_nr := ord (port) - ord ('0');
  end;


(* init *)
var i,
    j            : integer;
    printer_port : byte;
    multiport    : string;
begin
  clrscr;

  multipath := getenv ('multipath'); (* read environment variables *)
  multiport := getenv ('multiport');

  if multipath           = '' then error_msg (1, 0); (* undefined? *)
  if length (multiport)  >  1 then error_msg (3, 0); (* too long?  *)
  if multiport           = '' then printer_port := 1 (* default!   *)
                              else printer_port := get_port_nr (multiport);

  pout := memw [$40:$8 + (printer_port - 1) * 2];
  p_in := pout + 1;

  for i := 1 to 6 do
    for j := 1 to 6 do
      with assignment [i, j] do begin
        address := 0;
        pin     := none;
      end;
end;


procedure test_sticks;
(* ask user to push a specified joystick into a specified direction *)
(* scanning the printer port for changes                            *)


  function direction_found (var stick : Taddress) : boolean;
  (* finds printer port address that has changed due to user's stick
     movement
     returns TRUE if successful,
             FALSE if aborted by user or intended pin already used   *)


    function in_port : byte;
    (* reads printer port, i.e. PAPER EMPTY and BUSY bits *)
    begin
      in_port := port [p_in];
    end;


    procedure out_port (b : byte);
    (* joystick switch address byte output to printer port    *)
    (* always two switches addressed at once                  *)
    (* one is connected to PAPER EMPTY, the other one to BUSY *)
    begin
      port [pout] := b or $10; { $10 provides power supply for multi018}
    end;


    function pin_unused (add_now : byte; pin_now : Tpin) : boolean;
    (* TRUE if ADDRESS/PIN combination is not used anywhere in ASSIGNMENT *)
    var unused : boolean;
        i,
        j      : integer;
    begin
      unused := true;
      for i := 1 to 6 do
        for j := 1 to 6 do
          with assignment [i, j] do
            if (pin = pin_now) and (address = add_now)
              then unused := false;

      pin_unused := unused;
    end;


    procedure beep (frequency : integer);
    (* beeps *)
    begin
      sound (frequency);
      delay (50);
      nosound;
    end;


  (* direction_found *)
  var i      : byte;
      pin    : Tpin;
      signal : byte;
  begin
    i := 0;
    repeat until readkey <> '';

    repeat
      out_port (i);
      signal := in_port;
      pin := none;
      if (signal and $20) <> 0 then pin := pe;
      if (signal and $80) =  0 then pin := busy;
      inc (i);
    until (pin <> none) or (i > 15);

    if pin <> none
      then begin
        if pin_unused (i - 1, pin)
          then begin
            stick.address   := i - 1;
            stick.pin       := pin;
            direction_found := true;
            beep (440);
          end else begin
            direction_found := false;             (* pin already used *)
            beep (880);
          end;
      end else begin
        direction_found := false;
        beep (880);
        beep (440);
        beep (880);
      end;
  end;


(* test_sticks *)
var j,
    k,
    xtracount : integer;
begin
  xtracount := 0;
  for j := 1 to 6 do begin
    clrscr;
    writeln ('Press any key when you have moved the joystick as requested!');
    writeln;
    writeln ('Joystick #', j);
    for k := 1 to 5 do begin
      writeln ('     ', direction [k]);
      repeat until direction_found (assignment [j, k]);
    end;
    if xtracount < 2 then begin
      writeln ('     ', direction [6]);
      if direction_found (assignment [j, 6]) then inc (xtracount);
    end;
  end;
end;


procedure write_file;
(* write the config information to a disk file *)
var config   : text;


    procedure upcase_str (var to_upcase : string);
    (* upcases a string *)
    var i : integer;
    begin
      for i := 1 to length (to_upcase) do
        to_upcase [i] := upcase (to_upcase [i]);
    end;


    function action_written (add_now : byte; pin_now : Tpin) : boolean;
    (* writes a specified action to config file
       returns TRUE  if action written
       returns FALSE if no action found *)
    var found : boolean;
        j,
        k     : byte;
    begin
      found := false;
      j := 0;
      repeat
        inc (j);
        k := 0;
        repeat
          inc (k);
          with assignment [j, k] do
            if (address = add_now) and (pin = pin_now)
              then begin
                found := true;
                write (config, ' ', j, ' ', action [k]);
              end;
        until (k >= 6) or found;
      until (j >= 6) or found;
      action_written := found;
    end;


var multicfg : string [8];
    answer   : char;
    error    : integer;
    i,
    j,
    k        : byte;
(* write_file *)
begin
  repeat
    clrscr;
    writeln ('Name of config file: ');
    repeat
      readln(multicfg);
    until (length (multicfg) > 0) and (pos ('.', multicfg) = 0);
    upcase_str (multicfg);

    if multipath[length(multipath)] = '\' then
      assign (config, multipath + multicfg + '.cfg')
    else
      assign (config, multipath + '\' + multicfg + '.cfg');

    {$I-}
    reset (config);
    {$I+}
    error := ioresult;
    if error = 0 then begin
      writeln;
      writeln (multicfg, '.CFG already exists. Overwrite?');
      repeat
        answer := upcase (readkey);
      until answer in ['Y', 'N'];
    end;
  until (error <> 0) or (answer = 'Y');
  {$I-}
  rewrite (config);
  {$I+}
  error := ioresult;
  if error <> 0 then error_msg (4, error);
  for i := 0 to 15 do begin
    write (config, i);
    if i < 10 then write (config, ' ');
    if not action_written (i, pe)   then write (config, ' 1 *');
    if not action_written (i, busy) then write (config, ' 2 *');
    if i < 15 then writeln (config);
  end;

  close (config);

  writeln (multicfg, '.CFG written successfully');
end;


(* multijoy_config_file_maker *)
begin
  init;
  test_sticks;
  write_file;
end.